-----------------------------------------------------------------------------
--
-- Module      :  Data.Units.Generator
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :  Eduard Sergeev
-- Stability   :  Highly Experimental
-- Portability :
--
-- Generation of custom Units definitions
--
-----------------------------------------------------------------------------

{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, TypeOperators, TypeFamilies, NoMonomorphismRestriction,
FlexibleInstances, MultiParamTypeClasses, DeriveFunctor, DeriveFoldable, DeriveTraversable,
FlexibleContexts #-}


module Data.Units.Generator
(

   U,

   ToNumber,
   ToList,
   FromList,

   (:::),
   quantitify,

   Multiply,
   Divide,

   unit,

   toPeano,

)
where

import qualified Prelude as P
import Data.Either
import Data.Function
import Data.Char
import Data.List
import Text.Show
import Text.Read (read)
import Control.Monad
import Data.Monoid

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Data.Units.Types
import Data.Units.Instances
import qualified Data.TypeLevel.Peano as PN
import qualified Data.TypeLevel.Numbers as N
import qualified Data.TypeLevel.List as L
import Data.TypeLevel.Bit

import Text.Parsec
--import Text.Parsec.Token
import qualified Text.Parsec.Token as PP
import Text.Parsec.Language (haskellDef)
import Text.Parsec.Expr

import Control.Applicative hiding  ((<|>), many)
import Control.Monad.State

toPeano 0 = [t| PN.Zero |]
toPeano n = [t| PN.Succ $(toPeano (P.pred n)) |]

toNumber 0 = [t| N.Zero |]
toNumber n = [t| N.BInteger $(toBList n) |]
    where
      toBList 0 = [t| L.Nil |]
      toBList n = [t| $(toBoolean m) L.::: $(toBList d) |]
          where
            (d,m) = n `P.divMod` 2
            toBoolean 0 = [t| B0 |]
            toBoolean 1 = [t| B1 |]


uData dName = dataD (return []) (mkName dName) [] [] []

uCheckData n = dataD (return []) (mkName $ "UnitOrder_" ++ show n) [] [] []


uSyn dName = tySynD (mkName dName) []    

--instance Show S where show _ = "s" 
uInst :: String -> String -> DecQ
uInst dName tag = head <$> [d|instance Show $(conT $ mkName dName) where show _ = $(litE $ stringL tag) |]

--type instance ToPeano S = Three
uTPeanoInst sName n = tySynInstD (mkName "ToNumber") [conT $ mkName sName] (toPeano n)
--uTPeanoInst sName n = tySynInstD (mkName "ToNumber") [conT $ mkName sName] (toNumber n)


--type instance ToList S = U :*: S
uToListInst :: String -> DecQ
uToListInst sName = tySynInstD (mkName "ToList") [uName]  [t|U :*: $(uName)|]
    where uName = conT $ mkName sName

--type instance FromList (U :*: S) = S
uFromListInst1 :: String -> DecQ
uFromListInst1 sName = tySynInstD (mkName "FromList") [[t|U :*: $(uName)|]] uName
    where uName = conT $ mkName sName

--type instance FromList ((a :*: b) :*: S) = (FromList (a :*: b)) :*: S
uFromListInst2 :: String -> DecQ
uFromListInst2 sName = tySynInstD (mkName "FromList") [[t|($a :*: $b) :*: $uName|]] [t|(FromList ($a :*: $b)) :*: $uName|]
    where
      a = varT $ mkName "a"
      b = varT $ mkName "b"
      uName = conT $ mkName sName

-- UM 1 :: Num n => n ::: M
uOneVar :: String -> String -> Q [Dec]
uOneVar dName vName = do
  t <- sigD (mkName vName) (forallT [PlainTV (mkName "n")] (cxt [classP (mkName "Num") [n]]) ([t|$n ::: $(t)|]))
  v <- valD (varP $ mkName vName) (normalB [| quantitify 1|]) []
  return [t,v]
      where
        t = conT $ mkName dName
        n = varT $ mkName "n"


uConv :: String -> String -> Q [Dec]
uConv name fName = do
    let fn = mkName fName
        nn = varT $ mkName "n"
        t = conT (mkName name) 
    f <- funD fn [clause [] (normalB [| quantitify |]) []]
    s <- sigD fn (forallT [PlainTV (mkName "n")] (cxt [classP (mkName "Num") [nn]]) ([t|$(nn) ::: U -> $(nn) ::: $(t)|]))
    return [s,f]


-- * Parsers

-- | Parser for measure definition
measureDef = try base <|> derived

typeName = (:) <$> upper <*> many alphaNum
showName = many1 alphaNum
convName = (:) <$> lower <*> many alphaNum
varName = (:) <$> (char '_' <|> lower) <*> many alphaNum

-- | Base measure definition: M(metres)m<m>:5
base = do
  spaces
  tn <- typeName
  spaces
  f <- return [] `option` (uConv tn <$> inPar convName)
  spaces
  v <- return [] `option` (uOneVar tn <$> varName)
  spaces
  sn <- tn `option` between (char '<') (char '>') (many1 letter)
  inSpa $ char ':'
  ns <- many1 digit
  let n = read ns
  return $ liftM2 (++) (liftM2 (++) f v) $
         sequence [
              uData tn,
              uCheckData n,
              uInst tn sn,
              uTPeanoInst tn n,
              uToListInst tn,
              uFromListInst1 tn,
              uFromListInst2 tn]

-- | Derived unit definition: Rad(radians)=ex
derived = do
  spaces
  tn <- typeName
  spaces
  f <- return [] `option` (uConv tn <$> inPar convName)
  spaces
  v <- return [] `option` (uOneVar tn <$> varName)
  inSpa $ char '='
  e <- ex
  return $ liftM2 (:) (uSyn tn e) (liftM2 (++) f v)
--  return $ liftM2 (:) (uSyn tn [t| Force $e |]) (liftM2 (++) f v)








-- | Parser for types expressions
-- " M/(S * (1/M))"


lexer = PP.makeTokenParser haskellDef
natural = PP.natural lexer

ex = inSpa arg2 `chainl1` app
mu = char '*' >> pure "Multiply"
di = char '/' >> pure "Divide"
pow = do
  a <- arg 
  char '^'
  n <- natural
  return $ appT (appT (conT $ mkName "Power") a) (toPeano n)

arg2 = try pow <|> arg


ty = conT . mkName <$> choice [many1 letter , char '1' >> pure "U"]
op = conT . mkName <$> choice [mu , di]
app = do { o <- op ; return $ appT . appT o }
arg = inPar ex <|> ty
--arg = pow <|> inPar ex <|> ty


inPar = char '(' `between` char ')'
inSpa p = spaces *> p <* spaces

typeQuoter = either (fail . show) id . parse ex ""
derivedQuoter = either (fail . show) id . parse derived ""
measureQuoter = either (fail . show) id . parse measureDef ""

unit :: QuasiQuoter
unit = QuasiQuoter {
            quoteType = typeQuoter,
            quoteDec = measureQuoter,
            quoteExp = fail "Unit of measurement expressions are not supported",
            quotePat = fail "Unit of measurement patterns are not supported" }
